home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / SysGen / HISTORY < prev    next >
Encoding:
Text File  |  1992-01-24  |  12.7 KB  |  559 lines
  1. \ Command Line History
  2. \ Provide Shell like History for JForth
  3. \
  4. \ Useful words for you to know are:
  5. \ HISTORY.ON   HISTORY.OFF
  6. \ HISTORY      HISTORY#     XX
  7. \ $>EXPECT   FKEY-VECTORS
  8. \
  9. \ Author: Phil Burk
  10. \ Copyright 1988 Phil Burk
  11. \
  12. \ MOD: PLB 1/22/98 Fixed bad comment in HISTORY.RESET
  13. \ MOD: PLB 2/13/89 Use value of EXPECT as flag for ON/OFF.
  14. \ MOD: PLB 7/10/89 Change SMART.KEY to allow special keys > 128.
  15. \ MOD: PLB 6/11/90 Added KH.SHIFT.DOWN.ARROW
  16. \ MOD: PLB 12/12/90 Fixed KH.SHIFT.DOWN.ARROW , KLINES OFF
  17. \ MOD: PLB 12/31/90 LIST.FKEYS c/20 1/21 1/ , thanks M. Kees
  18. \ MOD: PLB 1/8/91 Add hooks to allow word completion.
  19. \ MOD: PLB 7/9/91 Recovered from old disk, c/ju:ansi/jf:ansi/
  20. \ 00001 PLB 1/17/92 Clear TIB in AUTO.INIT to prevent INTERPRET
  21. \                from picking up old input.
  22. \ 00002 PLB 1/21/92 Use ANSI.BACKWARDS and ANSI.DELETE in KH.BACKSPACE
  23. \ 00003 mdh 20-jan-92 KH.GETLINE examines ExpectNulls variable
  24. \               This was added because the AmigaDOS 2.04 Cut/Paste
  25. \               inserts NULS for some unknown reason.
  26. \ 00004 PLB 1/24/92 Replace TABs with the correct number of spaces.
  27. \ 00005 PLB 1/24/92 Moved zeroing of TIB to kernel.
  28.  
  29. include? ansi.backwards jf:ansi
  30.  
  31. ANEW TASK-HISTORY
  32. decimal
  33.  
  34. .NEED ODDW@   ( this should be in kernal )
  35. : ODDW@ ( addr -- w )
  36.     dup c@ 8 shift
  37.     swap 1+ c@ or
  38. ;
  39. .THEN
  40.  
  41. \ You can expand the history buffer by increasing this constant.
  42. 512 constant KH_HISTORY_SIZE
  43.  
  44. create KH-HISTORY kh_history_size allot
  45.  
  46. \ An entry in the history buffer consists of
  47. \   a Count byte = N,
  48. \   N chars,
  49. \   16 bit line number,
  50. \   another Count byte = N
  51. \
  52. \ The most recent entry is put at the beginning,
  53. \ older entries are shifted up.
  54.  
  55. : KH-END ( -- addr , end of history buffer )
  56.     kh-history kh_history_size +
  57. ;
  58.  
  59. variable KH-LOOK   ( index of history line , point to count )
  60. variable KH-LINES  ( count of lines back )
  61. variable KH-COUNT  ( temporary storage )
  62. variable KH-MAX
  63. variable KH-COUNTER ( 16 bit counter for line # )
  64. variable HIGHLIGHT-INPUT  ( if true, input in f:3 )
  65. variable KH-MATCH-SPAN  ( span for matching on shift-up )
  66.  
  67. highlight-input on  ( turn on as default !! )
  68.  
  69.  
  70. variable KH-CURSOR ( points to next insertion point )
  71. variable KH-ADDRESS  ( address to store chars )
  72.  
  73. variable TAB-WIDTH \ 00004
  74. 4 tab-width !
  75.  
  76. : KH-BUFFER ( -- buffer )
  77.     kh-address @
  78. ;
  79. : KH.MAKE.ROOM ( N -- , make room for N more bytes at beginning)
  80.     >r  ( save N )
  81.     kh-history dup r@ + ( source dest )
  82.     kh_history_size r> - 0 max move
  83. ;
  84.  
  85. : KH.RECENT.LINE  ( -- addr count , most recent line )
  86.     kh-history count
  87. ;
  88.  
  89. : KH.CURRENT.ADDR ( -- $addr , count byte of current line )
  90.     kh-look @ kh-history +
  91. ;
  92.  
  93. : KH.CURRENT.LINE ( -- addr count )
  94.     kh.current.addr count
  95. ;
  96.  
  97. : KH.COMPARE ( addr count -- flag , true if redundant )
  98.     kh.recent.line nip =
  99.     IF  kh.recent.line compare 0=
  100.     ELSE drop false
  101.     THEN
  102. ;
  103.  
  104. : KH.NUM.ADDR ( -- addr , address of current line count )
  105.     kh.current.line +
  106. ;
  107.  
  108. : KH.CURRENT.NUM ( -- # , number of current line )
  109.     kh.num.addr oddw@
  110. ;
  111.  
  112. : KH.ADDR++  ( $addr -- $addr' , convert one kh to previous )
  113.     count + 3 +
  114. ;
  115. : KH.ADDR--  ( $addr -- $addr' , convert one kh to next )
  116.     dup 1- c@ - cell-
  117. ;
  118.  
  119. : KH.ENDCOUNT.ADDR ( -- addr , address of current end count )
  120.     kh.num.addr 2+
  121. ;
  122.  
  123. : KH.ADD.LINE ( addr count -- )
  124.     dup 256 >
  125.     IF ." KH.ADD.LINE - Too big for history!" 2drop
  126.     ELSE   ( add to end )
  127. \ Compare with most recent line.
  128.         2dup kh.compare
  129.         IF 2drop
  130.         ELSE
  131.             >r ( save count )
  132. \ Set look pointer to point to first count byte of last string.
  133.             0 kh-look !
  134.             r@ cell+ kh.make.room
  135. \ Set count bytes at beginning and end.
  136.             r@ kh-history c!  ( start count )
  137.             r@ kh.endcount.addr c!
  138.             kh-counter @ kh.num.addr oddw!  ( line )
  139. \ Number lines modulo 1024
  140.         kh-counter @ 1+ $ 3FF and kh-counter !
  141.             kh-history 1+   ( calc destination )
  142.             r> cmove  ( copy chars into space )
  143.         THEN
  144.     THEN
  145. ;
  146.  
  147. : KH.ADD.BUFFER ( -- , add text currently in buffer )
  148.     span @ 0>
  149.     IF kh-buffer span @ kh.add.line
  150.     THEN
  151. ;
  152.  
  153. : KH.BACKUP.LINE  ( -- atend? , advance KH-LOOK if in bounds )
  154.     true  ( default flag, at end of history )
  155. \ KH-LOOK points to count at start of current line
  156.     kh.current.addr c@ ( -- count )
  157.     IF  kh.current.addr kh.addr++ kh-end <
  158.         IF  kh.current.addr kh.addr++ kh-history - kh-look !
  159.             1 kh-lines +!
  160.             drop false
  161.         THEN
  162.     THEN
  163. ;
  164.  
  165. : KH.PREVIOUS.LINE ( -- addr count | 0 , find previous line in history )
  166.     kh.current.line
  167.     kh.backup.line
  168.     IF 2drop 0
  169.     THEN
  170. ;
  171.  
  172. : KH.FORWARD.LINE ( -- atstart? )
  173. \ KH-LOOK points to count at start of current line
  174.     kh-lines @ 0>
  175.     IF  kh.current.addr kh.addr--
  176.         kh-history - kh-look !
  177.         -1 kh-lines +! false
  178.     ELSE
  179.         kh-lines off
  180.         0 kh-look ! true
  181.     THEN
  182. ;
  183.  
  184. : KH.NEXT.LINE ( -- addr count | 0 , find next line if there )
  185.     kh.forward.line
  186.     IF 0
  187.     ELSE kh.forward.line 
  188.         IF 0 
  189.         ELSE kh.current.line kh.backup.line drop
  190.         THEN
  191.     THEN
  192. ;
  193.  
  194. : KH.OLDEST.LINE   ( -- addr count | 0, oldest in buffer )
  195.     BEGIN kh.backup.line
  196.     UNTIL
  197.     kh-lines @
  198.     IF  kh.forward.line drop kh.current.line
  199.     ELSE 0
  200.     THEN
  201. ;
  202.  
  203. : ?WAIT  ( -- )
  204.     ?terminal
  205.     IF  key drop f:2 ."  ?q" f:1
  206.         key $ 20 or ( convert to lower case ) ascii q =
  207.         IF  abort
  208.         THEN
  209.         3 ansi.backwards ansi.erase.eol
  210.     THEN
  211. ;
  212.  
  213. : HISTORY# ( -- , dump history buffer with numbers)
  214.     cr kh.oldest.line ?dup
  215.     IF  BEGIN kh.current.num 3 .r ." ) " type ?wait cr
  216.             kh.forward.line 0=
  217.         WHILE kh.current.line
  218.         REPEAT
  219.     THEN
  220. ;
  221.  
  222. : HISTORY ( -- , dump history buffer with numbers)
  223.     cr kh.oldest.line ?dup
  224.     IF  BEGIN type ?wait cr
  225.             kh.forward.line 0=
  226.         WHILE kh.current.line
  227.         REPEAT
  228.     THEN
  229. ;
  230.  
  231. : KH.FIND.LINE ( -- $addr )
  232.     BEGIN kh.current.num over -
  233.     WHILE kh.backup.line
  234.         IF ." Line not in History Buffer!" cr drop 0 exit
  235.         THEN
  236.     REPEAT
  237.     drop kh.current.addr
  238. ;
  239.  
  240. : XX  ( line# -- , execute line x of history )
  241.     kh.find.line ?dup
  242.     IF count $interpret
  243.     THEN
  244. ;
  245.  
  246.  
  247. : KH.RETURN ( -- , move to beginning of line )
  248.     13 emit ( true carriage return )
  249. ;
  250.  
  251. : KH.REPLACE.LINE  ( addr count )
  252.     kh.return
  253.     ansi.erase.eol
  254.     dup span !
  255.     dup kh-cursor !
  256.     2dup kh-buffer swap cmove
  257.     highlight-input @ IF f:3 THEN
  258.     type
  259.     highlight-input @ IF f:1 THEN
  260. ;
  261.  
  262. : KH.SHIFT.UP.ARROW ( -- , search for line with same start )
  263.     kh-match-span @ 0=  ( keep length for multiple matches )
  264.     IF span @ kh-match-span !
  265.     THEN
  266.     BEGIN kh.previous.line
  267.     WHILE kh-match-span @ kh-buffer text=?
  268.         IF kh.forward.line drop kh.current.line kh.replace.line
  269.            kh.backup.line drop exit
  270.         THEN
  271.     REPEAT
  272. ;
  273.  
  274. : KH.SHIFT.RIGHT.ARROW ( -- )
  275.     span @ kh-cursor @ - dup 0>
  276.     IF
  277.         ansi.forwards
  278.         span @ kh-cursor !
  279.     ELSE drop
  280.     THEN
  281. ;
  282.  
  283. : KH.SHIFT.LEFT.ARROW ( -- )
  284.     kh.return
  285.     kh-cursor off
  286. ;
  287.  
  288. : KH.UP.ARROW ( -- , goto previous line )
  289.     kh.previous.line ?dup
  290.     IF kh.replace.line
  291.     THEN
  292. ;
  293.  
  294. : KH.DOWN.ARROW ( -- , next line )
  295.     kh.next.line ?dup
  296.     IF kh.replace.line
  297.     ELSE tib 0 kh.replace.line
  298.     THEN
  299. ;
  300.  
  301. : KH.GOTO.HOME  ( -- )
  302.     0 kh-look !
  303.     0 kh-lines !
  304. ;
  305.  
  306. : KH.SHIFT.DOWN.ARROW ( -- , most recent line )
  307.     kh.goto.home
  308.     kh.current.line
  309.     kh.replace.line
  310. ;
  311.  
  312. : KH.RIGHT.ARROW
  313.     kh-cursor @ span @ <
  314.     IF 1 kh-cursor +!
  315.        1 ansi.forwards
  316.     THEN
  317. ;
  318.  
  319. : KH.LEFT.ARROW ( -- )
  320.     kh-cursor @ ?dup
  321.     IF 1- kh-cursor !
  322.        1 ansi.backwards
  323.     THEN
  324. ;
  325.  
  326. : KH.REFRESH  ( -- , redraw current line as is )
  327.     13 emit  ( true return )
  328.     highlight-input @ IF f:3 THEN
  329.     kh-buffer span @ type out @
  330.     highlight-input @ IF f:1 THEN
  331.     13 emit kh-cursor @ ?dup 
  332.     IF ansi.forwards
  333.     THEN out !
  334. ;
  335.  
  336. 21 ARRAY FKEY-VECTORS  ( f0 not used, f1-f20 )
  337.  
  338. : EXEC.FKEY  ( # -- , do function )
  339.     fkey-vectors @execute flushemit
  340. ;
  341.  
  342. : LIST.FKEYS ( -- )
  343.     >newline ." Function key assignments." cr
  344.     21 1
  345.     DO
  346.         i fkey-vectors @ dup ' noop -
  347.         IF  i 1- 10 /mod
  348.             IF ."   Shift-F" 1+ .
  349.             ELSE 8 spaces ASCII F emit 1+ .
  350.             THEN ."  = " >name id. cr
  351.         ELSE drop
  352.         THEN
  353.     LOOP cr
  354. ;
  355.     
  356. : KH.SPECIAL.KEY ( char -- , handle fkeys or arrows )
  357.     155 =  ( HIGH ESCAPE? )
  358.     IF ansi.parse.skr
  359.        dup 1 20 within?  ( function key )
  360.        IF exec.fkey kh.refresh
  361.        ELSE
  362.            CASE
  363.            25 OF kh.shift.up.arrow    ENDOF
  364.                0 kh-match-span ! ( reset if any other key )
  365.            21 OF kh.up.arrow    ENDOF
  366.            22 OF kh.down.arrow  ENDOF
  367.            23 OF kh.right.arrow ENDOF
  368.            24 OF kh.left.arrow  ENDOF
  369.            26 OF kh.shift.down.arrow  ENDOF
  370.            27 OF kh.shift.right.arrow ENDOF
  371.            28 OF kh.shift.left.arrow  ENDOF
  372.            29 OF list.fkeys kh.refresh ENDOF
  373.            ENDCASE
  374.        THEN
  375.     THEN
  376. ;
  377.  
  378. : SMART.KEY ( -- char )
  379.     BEGIN  key
  380. \        dup 128 >
  381.         dup 155 =  ( allow special ALT keys ! )
  382.     WHILE kh.special.key
  383.     REPEAT
  384. ;
  385.  
  386. : KH.BACKSPACE ( -- , backspace character from buffer and screen )
  387.     kh-cursor @ ?dup  ( past 0? )
  388.     IF
  389.         1 ansi.backwards \ 00002
  390.         1 ansi.delete
  391.         span @ <
  392.         IF  ( inside line )
  393.             kh-buffer kh-cursor @ +  ( -- source )
  394.             dup 1- ( -- source dest )
  395.             span @ kh-cursor @ - cmove
  396.         THEN
  397.         -1 span +!
  398.         -1 kh-cursor +!
  399.     ELSE 7 emit ( beep )
  400.     THEN
  401. ;
  402.  
  403. : KH.DELETE ( -- , forward delete )
  404.     kh-cursor @ span @ <  ( before end )
  405.     IF  ( inside line )
  406.         1 ansi.delete
  407.         kh-buffer kh-cursor @ + 1+ ( -- source )
  408.         dup 1- ( -- source dest )
  409.         span @ kh-cursor @ - 0 max cmove
  410.         -1 span +!
  411.     THEN
  412. ;
  413.  
  414. : KH.CONTROLX ( -- , kill line )
  415.     13 emit  ( true carriage return )
  416.     span @ 0 DO 1 ansi.delete LOOP
  417.     kh-cursor off span off out off
  418. ;
  419.         
  420. : KH.INSCHAR  ( char -- )
  421.     kh-cursor @ span @ <
  422.     IF  ( inside line )
  423.         1 ansi.insert
  424. \ Move characters up
  425.         kh-buffer kh-cursor @ +  ( -- source )
  426.         dup 1+ ( -- source dest )
  427.         span @ kh-cursor @ - cmove>
  428.     THEN
  429.     highlight-input @ IF f:3 THEN
  430.     dup emit
  431.     highlight-input @ IF f:1 THEN
  432.     kh-buffer kh-cursor @ + c!
  433.     1 kh-cursor +!
  434.     1 span +!
  435. ;
  436.  
  437. : TEXT>EXPECT ( addr count -- , insert into input )
  438.     kh-max @ span @ - min 0
  439.     DO dup i + c@ kh.inschar
  440.     LOOP drop
  441. ;
  442.  
  443. : $>EXPECT ( $address -- , insert a string into input stream )
  444.     count text>expect
  445. ;
  446.  
  447. : KH.TAB ( -- , insert the proper number of spaces for a tab 00004 )
  448.     out @
  449.     tab-width @ tuck mod -  \ calculate # of spaces to add
  450.     0
  451.     DO BL kh.inschar
  452.     LOOP
  453. ;
  454.  
  455. : KH.GETLINE ( max -- )
  456.     kh-max !
  457.     span off
  458.     kh-cursor off
  459.     0 kh-look !
  460.     0 kh-match-span !
  461.     BEGIN
  462.         kh-max @ span @ >
  463.         IF
  464.            BEGIN
  465.               smart.key  ExpectNulls @   \ 00003 
  466.               IF
  467.                  true
  468.               ELSE
  469.                  ?dup
  470.               THEN
  471.            UNTIL
  472.            dup 13 -  ( <cr?> )
  473.         ELSE 0 false
  474.         THEN  ( -- char flag )
  475.     WHILE ( -- char )
  476.         CASE
  477.         bsin @ OF kh.backspace ENDOF
  478.         127  OF kh.delete ENDOF
  479.          24  OF kh.controlx ENDOF
  480.           9  OF kh.tab ENDOF \ 00004
  481.         dup kh.inschar
  482.         ENDCASE
  483.     REPEAT drop
  484.     span @ kh-cursor @ - ?dup
  485.     IF 1+ ansi.forwards  ( move to end of line )
  486.     ELSE space
  487.     THEN
  488.     flushemit
  489. ;
  490.  
  491. : KH.EXPECT ( addr max -- )
  492.     swap kh-address !
  493.     kh-lines off
  494.     kh.getline
  495.     kh.add.buffer
  496. ;
  497.  
  498. : HISTORY.ON ( -- , install history vectors )
  499.     what's expect ' (expect) =
  500.     IF ' kh.expect is expect
  501.     THEN
  502. ;
  503.  
  504. : HISTORY.OFF ( -- , deinstall )
  505.     what's expect ' kh.expect =
  506.     IF ' (expect) is expect
  507.     THEN
  508. ;
  509.  
  510. : "INCLUDE" ( -- , add string to input )
  511.     " INCLUDE " $>EXPECT ;
  512. : "WORDS-LIKE" ( -- )
  513.     " WORDS-LIKE " $>EXPECT ;
  514. : "FILE?" ( -- )
  515.     " FILE? " $>EXPECT ;
  516. : "EACH.FILE?" ( -- )
  517.     " EACH.FILE? " $>EXPECT ;
  518.  
  519. : PANIC.BUTTON ( -- , reset things in system in attempt to recover)
  520.     ." Attempt Reset - HASH.OFF ONLY FORTH ALIGN " cr
  521.     ."   DETACHMODULES HISTORY.OFF ABORT" cr
  522.     ." Proceed? " y/n
  523.     IF  hash.off
  524.         ." Hashing OFF!" cr
  525.         only forth definitions order
  526.         align
  527.         detachmodules
  528.         history.off
  529.         abort
  530.     THEN
  531. ;
  532.  
  533. : HISTORY.RESET  ( -- , reset vectors and clear table )
  534.     21 0 DO ' noop i fkey-vectors ! LOOP
  535.     ' "include" 1 fkey-vectors !
  536.     ' map 2 fkey-vectors !
  537.     ' history# 3 fkey-vectors !
  538.     ' dir 4 fkey-vectors !
  539.     ' vlist 5 fkey-vectors !
  540.     ' "words-like" 6 fkey-vectors !
  541.     ' "file?" 7 fkey-vectors !
  542.     ' "each.file?" 8 fkey-vectors !
  543.     ' panic.button 11 fkey-vectors !
  544. \
  545.     kh-history kh_history_size erase
  546.     kh-counter off
  547. ;
  548.  
  549. : AUTO.INIT
  550.     auto.init
  551.     history.on
  552. \    0 #tib ! \ 00001 , moved to kernel 00005
  553. ;
  554.  
  555. if.forgotten history.off
  556.  
  557. history.reset
  558. history.on
  559.